home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / Pocket6.3 / Examples / Reader < prev    next >
Text File  |  1994-06-24  |  21KB  |  492 lines
  1. ( Reader application for Pocket Forth 0.6.3 )
  2. : RTEST ( -- ) key 13 = 0= IF bye ?terminal drop THEN  0 28 +md ! ;
  3. page
  4. ( *******************  W A R N I N G  ******************** )
  5. (   This file creates the ReadMe application. Do NOT run   )
  6. ( this file on a normal copy of Pocket Forth. Instead make )
  7. ( a SPECIAL copy using ResEdit:                            )
  8. (   1} Open a copy of ReadMe with ResEdit                  )
  9. (   2} Delete the DICT 257 resource from ReadMe            )
  10. (   3} Open a copy of Pocket Forth with ResEdit            )
  11. (   4} Copy the DICT 257 resource from Pocket Forth        )
  12. (   5} Paste the DICT 257 resource into ReadMe             )
  13. (   6} Save ReadMe with ResEdit                            )
  14. (   7} Quit ResEdit and Open ReadMe                        )
  15. (   8} Type "open" and open Reader                         )
  16. (   9} Press the return key, wait until ReadMe quits.      )
  17. (  10} Restart ReadMe.                                     )
  18. (  Type return to continue, anything else to quit. )  rtest
  19.  
  20. forget task : task ;
  21.  
  22. : !FONT ( n -- ) >r ,$ A887 ; macro  ( _TextFont )
  23. : !FSIZE ( n -- ) >r ,$ A88A ; macro  ( _TextSize )
  24. : !FACE ( face -- ) >r ,$ A888 ; macro ( _TextFace )
  25. : SFONT ( -- ) 0 !font  12 !fsize ;  ( 12 point Chicago )
  26. : NFONT ( -- ) 4 !font  12 !fsize ;  \ 12 point Monaco
  27. : LFONT ( -- ) nfont  9 !fsize ;     \  9 point Monaco
  28. : CLS ( -- ) 4 +md a>r ,$ A8A3  20 20 !pen ;  ( CLear Screen )
  29.  
  30. ( old style colors )
  31. : BLACK    33 0 2>r ,$ A862 ;  ( black _ForeColor )
  32. : RED     205 0 2>r ,$ A862 ;  ( red _ForeColor )
  33. : BLUE     409 0 2>r ,$ A862 ;  ( blue _ForeColor )
  34.  
  35. ( rect words )
  36. : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ;
  37. : !RECT ( t l b r rect -- ) >r  swap r 4 + 2!  swap r> 2! ;
  38. : @RECT ( rect -- t l b r ) dup 2@ swap  rot 4 + 2@ swap ;
  39. : ROFFSET ( h v rect -- ) a>r 2>r ,$ A8A8 ;  ( _OffsetRect )
  40. : RINSET ( h v rect -- ) a>r 2>r ,$ A8A9 ;  ( _InsetRect )
  41. : ?EMPTY ( rect -- flag ) 0 >r a>r ,$ A8AE r> ;  ( _EmptyRect )
  42. : RERASE ( rect -- ) a>r ,$ A8A3 ;  ( _EraseRect )
  43.  
  44. : ?PHIT ( h v poly -- flag ) ( true if h,v is in polyBBox )
  45.     0 >r  2@ dl@  2 0 d+  2swap 2>r  2>r ,$ A8AD r> ;  ( _PtInRect )
  46. : POLYGON ( addr -- ) 0 0 2>r ,$ A8CB 2r> rot 2! ;  ( _OpenPoly )
  47.  
  48. ( print PICT resources from this file )
  49. : GETPICT ( id -- dhandle ) 0 0 2>r  >r  ,$ A9BC  2r> ;  ( _GetPict )
  50. : PDRAW ( rect dhandle -- ) ( draw a picture in rect )
  51.     2>r a>r ,$ A8F6 ;  ( _DrawPicture )
  52. : DPICT ( rect id -- ) getpict  pdraw ;
  53.  
  54. ( create and destroy pictures )
  55. : PICTURE ( rect -- dhandle ) ( open a picture )
  56.     0 0 2>r  a>r  ,$ A8F3 2r> ;  ( _OpenPicture )
  57. : PCLOSE ,$ A8F4 ; macro  ( _ClosePicture )
  58. : PKILL ( addr -- ) 2@ 2>r ,$ A8F5 ; ( _KillPicture at addr )
  59.  
  60. \ color availability testing
  61. : ?COLOR ( -- f ) \ true if color is available and system>6.0.4
  62.     ,s qd   ?gestalt dup IF  2drop 256 < 0= THEN ; 
  63.  
  64. ( icons )
  65. : CIGET ( id -- d.handle ) ( call once per icon )
  66.     0 0 2>r >r  \ push room and id
  67.     ?color IF ,$ AA1E      ( _GetCIcon )
  68.     ELSE ,$ A9BB  THEN 2r> ;  ( _GetIcon )
  69. : CIPLOT ( rect d.handle -- ) \ draw icon in rect
  70.     rot a>r 2>r
  71.     ?color IF ,$ AA1F  ( _PlotCIcon )
  72.     ELSE ,$ A94B  THEN ;  ( _PlotIcon )
  73.  
  74.  
  75. ( polygons for the 'NEXT' and 'PREV' "buttons" )
  76. 2variable APOLY  ( aft button poly handle  )
  77. 2variable FPOLY  ( fore button poly handle )
  78. : +APOLY ( -- ) apoly polygon
  79.     5 225 !pen 20 210 -to 50 210 -to
  80.     50 240 -to 20 240 -to  5 225 -to
  81.     ,$ A8CC ;  ( _ClosePgon )
  82. : +FPOLY ( -- ) fpoly polygon
  83.     440 225 !pen 425 210 -to 390 210 -to
  84.     390 240 -to  425 240 -to 440 225 -to
  85.     ,$ A8CC ;  ( _ClosePgon )
  86.  
  87. ( display "buttons" )
  88. : .POLY ( addr -- ) blue  2@ 2>r ,$ A8C6  black ;  ( _FramePoly )
  89. : .AARROW ( -- ) 015 230 !pen ." Prev"  apoly .poly ;
  90. : .FARROW ( -- ) 396 230 !pen ." Next"  fpoly .poly ;
  91. : .ARROWS ( -- ) .aarrow .farrow ;
  92.  
  93.  
  94. \ display icons
  95. variable ICONTABLE  0 iconTable !  12 allot   \ room for 2 icons
  96.     ( no.of.entries   id#1  handle#1  id#2  handle#2  )
  97. : >ICON ( index -- addr ) 6 * iconTable 2+ + ; \ icon list entry (0 based)
  98. : +ICON ( id -- ) \ loads icon from disk and stores data in table
  99.     iconTable @ >icon   \   get entry address
  100.     2dup !               \  store id into table
  101.     swap ciget rot 2+ 2!  \ get & store handle
  102.     1 iconTable +! ;
  103. : .ICON ( id rect -- ) \ display icon in rect
  104.     SWAP  iconTable @ 0 DO  \  search the icon table ..
  105.       r >icon @ over = IF    \ .. for the id wanted
  106.         drop  r >icon 2+ 2@  ciplot LEAVE
  107.     THEN  LOOP ;
  108.  
  109.  
  110. \ Flying Bird stuff
  111. rect BRECT  0 0 14 28 brect !rect  ( the bird's rect )
  112. rect OBRECT  0 0 0 0 obrect !rect  ( old brect )
  113. 2variable B1PICT  ( hold b1's pict handle )
  114. 2variable B2PICT  ( hold b2's pict handle )
  115. 2variable B3PICT  ( hold b3's pict handle )
  116.  
  117. ( draw the three bird positions )
  118. : .B1  red 2 0 !pen 6 0 -to 12 6 -to 18 0 -to 22 0 -to  black ;
  119. : .B2  red 0 6 !pen 24 6 -to black ;
  120. : .B3  red 2 12 !pen 6 12 -to 12 6 -to 18 12 -to 22 12 -to black ;
  121.  
  122. : +BIRD \ initialize the birds pictures & store the handles
  123.     brect picture .b1 pclose b1pict 2!
  124.     brect picture .b2 pclose b2pict 2!
  125.     brect picture .b3 pclose b3pict 2!
  126.     0 0 0 0 brect !rect  0 0 0 0 obrect !rect ;
  127. : -BIRD  b1pict pkill b2pict pkill b2pict pkill ;
  128.  
  129. : B1 brect b1pict 2@ pdraw ;
  130. : B2 brect b2pict 2@ pdraw ;
  131. : B3 brect b3pict 2@ pdraw ;
  132. create .BS  ' b1 ,  ' b2 ,  ' b3 ,  ( bird draw array )
  133. variable BTHIS  0 bthis !  ( offset to the current routine )
  134. 4 constant #BIRDS  \ (number_of_birds-1)*2
  135.  
  136. : THISBIRD ( -- n ) bthis @ ;  \   the current bird
  137. : NEXTBIRD ( -- ) 2 bthis +! ;  \  set bthis to the next bird
  138. : FIRSTBIRD ( -- ) 0 bthis ! ;   \ first picture in sequence
  139. : .BIRD ( n -- ) .bs + @  execute ;  \ draw bird n
  140.  
  141. : MOVEBIRD 3 -1 brect roffset ;  \  translate brect down1 for 3right
  142. : SHRINKBIRD 1 1 brect rinset ;   \ shrink brect by 2 pixels
  143.  
  144. : ANIMATE ( -- ) ( draw the flying red bird )
  145.     brect ?empty IF                   \ if bird has shrunk to oblivion...
  146.       48 291 60 309 brect !rect  THEN  \ ...restore its origonal size
  147.     obrect rerase                  \   erase the old rect
  148.     brect @rect obrect !rect        \  set old rect to current rect
  149.     0 -1 obrect rinset               \ expand old rect for full erasure
  150.     thisBird .bird                    \ draw the bird
  151.     thisBird #birds < IF            \    if its bird 1 or 2
  152.       nextBird  moveBird             \   increment bird and move rect
  153.     ELSE                              \  its bird 3
  154.       firstBird moveBird shrinkBird    \ cycle, move & shrink
  155.     THEN ;
  156.  
  157.  
  158. ( rects for pictures )
  159. rect PRECT   15  48 212 405 prect !rect  ( title picture rect )
  160. rect SRECT  192 222 221 370 srect !rect  ( signature rect )
  161. rect IRECT  170 194 203 227 irect !rect  ( icon rect )
  162.  
  163. : SCR ( -- ) @pen swap drop 16 + 50 swap !pen ;  ( special cr )
  164. : BCR ( -- ) @pen swap drop 50 swap !pen ;  ( cr without lf )
  165.  
  166. ( P1 - P? are page drawing routines.  They have no stack effect.)
  167. : P1  cls  prect 4000 dpict .farrow ;
  168.  
  169. : P2  cls scr
  170.     ."       Its FAST, its FUN and its FREE!" scr scr
  171.     ."    Its Pocket Forth, a programming language for" scr
  172.     ."  writing Macintosh applications and DAs." cr scr
  173.     ."    You can take advantage of many new features" scr
  174.     ."  in this release such as Apple Events*, Floating" scr
  175.     ."  Point, Gestalt** and Drag & Drop* programming." cr scr
  176.     ."    Learn Forth programming with the contents of" scr
  177.     ."  the Starting folder (inside the Extensions folder.)"
  178.     scr scr scr ."            * System 7   ** System 6.0.4+"
  179.     srect 4001 dpict  ( draw signature picture )
  180.     .arrows ;
  181.  
  182. : P3  cls scr
  183.     ."   Code produced by Pocket Forth is compact and fast." cr scr
  184.     ."   Pocket Forth produces true machine code, so" scr
  185.     ." you have complete control over your program." cr scr
  186.     ."   Examine and run the example and extension" scr
  187.     ." files for programming suggestions." cr scr
  188.     ."    If you have system 7 you can load text files by" scr
  189.     ."  dragging a text file icon onto Pocket Forth's icon." cr scr
  190.     ."  All systems can use the menu to “Open” a file."
  191.     143 392 176 425 irect !rect  ( set icon rect )
  192.     128 irect .icon  ( draw the icon )
  193.     .arrows ;
  194.  
  195. : P4  cls scr
  196.     ."   Print and read the Manual and the Glossary." cr scr
  197.     ."   The Manual consists of two TeachText documents" scr
  198.     ." suitable for use as a reference to Pocket Forth." cr scr
  199.     ."   The Glossary, also a TeachText document, is a" scr
  200.     ." list of the words in the Pocket Forth dictionary." scr
  201.     ." Stack effects, pronunciation and usage are shown." cr scr
  202.     ."   An addendum describes the desk accessory." cr scr
  203.     ."   Other document files abound." scr
  204.     .arrows ;
  205.  
  206. : P5  cls scr
  207.     ." Major changes since release 5:" scr scr
  208.     ."  • Floating point numbers!" cr scr
  209.     ."    Numeric input containing a decimal point is" scr
  210.     ."    interpreted as an extended floating point" scr
  211.     ."    number. Floating Point numbers are kept on" scr
  212.     ."    the stack as ten byte entities."  cr scr
  213.     ."    SANE is used along with three dozen new" scr
  214.     ."    words that manipulate floating point numbers." cr scr scr
  215.     ."                                ( continued ... )"
  216.     .arrows ;
  217.  
  218. : P6  cls scr
  219.     ." Floating point continued ..." cr scr
  220.     ."    Stack words:      "  2 !face
  221.                            ." fdrop   fdup   fswap   fpick" scr
  222.     ."                               fpack   froll   f>d   d>f" cr scr
  223.     0 !face ."    Memory words: " 2 !face ." f@   f!   fliteral   f," scr
  224.     ."                               fconstant   fvariable" cr scr
  225.     0 !face ."    I/O words:         " 2 !face
  226.                                     ." fnumber   sci   fix   f." cr scr
  227.     0 !face ."    Math words:      " 2 !face
  228.                                     ." fcompare   f+   f-   f*   f/" scr
  229.     ."                               frem   f^   fint   fabs   fsqrt" scr
  230.     ."                               fsin   fcos   ftan   fatn" scr
  231.     ."                               fexp   fln"  0 !face
  232.     .arrows ;
  233.  
  234.  
  235. : P7  cls scr
  236.     ."  • Apple Events:" cr scr
  237.     21 352 54 385 irect !rect  ( set icon rect )
  238.     128 irect .icon  ( draw the icon )
  239.     ."    Apple Events (System 7 required) are the" scr
  240.     ."    standard conduit for inter-application" scr
  241.     ."    communication. Pocket Forth programs may" scr
  242.     ."    define new Apple event handlers. The four" scr
  243.     ."    required events and all user defined events" scr
  244.     ."    are installed automatically when Pocket" scr
  245.     ."    Forth starts." cr scr
  246.     ."    Examples for HyperCard and Frontier are" scr
  247.     ."    in the 'Extensions:Apple Events' folder." cr scr
  248.     ."                                ( continued ... )"
  249.     .arrows ;
  250.  
  251.  
  252. : P8  cls scr
  253.     ." New words and variables control Apple Events:" cr scr
  254.     2 !face ."    AE:  " 0 !face ." and " 2 !face ." AE:  " 0 !face
  255.     ."    begin and end event definitions" scr
  256.     2 !face ."    ,S  " 0 !face
  257.     ."            compile (or stack) 4 bytes from ASCII" cr scr
  258.     2 !face  ."    +Md  " 0 !face ." variables:" scr
  259.     ."            136    Apple Event handler routine" scr
  260.     ."            188    Address of installation list" scr
  261.     ."            190    Error handler routine ("
  262.                          2 !face ." drop "  0 !face ." )" scr
  263.     ."            198    Reply record handle holder" scr
  264.     ."            202    Apple Event record handle"
  265.     .arrows ;
  266.  
  267. : P9  cls scr
  268.     ."  • Use " 2 !face ." ?gestalt  " 0 !face
  269.        ." to query the system." cr scr
  270.     ."    Using this new system trap, available since" scr
  271.     ."    late system 6, you can determine much about" scr
  272.     ."    the system software and hardware."  scr scr
  273.     ."  • A color conscious window is created if a" scr
  274.     ."    color machine is in use. This has no visual" scr
  275.     ."    effect but allows your programs to use color." scr scr
  276.     ."  • A new color icon and signature is used."
  277.     336 216 !pen  lfont ." p4TH" sfont
  278.     175 335 207 367 irect !rect  ( set icon rect )
  279.     129 irect .icon  ( draw the icon )
  280.     .arrows ;
  281.  
  282. : P10  cls scr
  283.     ." New for 6.3:" cr scr
  284.     ."  • The word \ makes comments more effecitve." cr scr
  285.     ."  • " 2 !face ." Warm  " 0 !face
  286.         ." restarts Pocket Forth, but leaves" scr
  287.     ."    the dictionary intact." cr scr
  288.     ."  • " 2 !face ." Depth  " 0 !face
  289.         ." lets you know how many items are" scr
  290.     ."    on the stack." scr scr
  291.     ."  • Check out the Balloon Help."
  292.     .arrows ;
  293.  
  294. : P11  cls scr
  295.     ." Bug fixes:" cr scr
  296.     ."  • The manual has been updated and now" scr
  297.     ."    prints with pictures, without errors." cr scr
  298.     ."  • " 2 !face ." Back  " 0 !face
  299.        ." now compiles correct branches." cr scr
  300.     ."  • A 32 bit address error in the update" scr
  301.     ."    routine has been fixed." cr scr
  302.     ."  • A new word, " 2 !face ." Bye  " 0 !face
  303.        ." does not use _ExitToShell." scr scr scr
  304.     ."                                ( continued ... )"
  305.     .arrows ;
  306.  
  307. : P12  cls scr
  308.     ." Bug fixes, continued ...       (New for 6.3)" cr scr
  309.     ."  • " 2 !face ." +LOOP  " 0 !face
  310.        ." now works correctly with" scr
  311.     ."    negative arguments." cr scr
  312.     ."  • " 2 !face ." TYPE  " 0 !face
  313.        ." does not end with a space." cr scr
  314.     ."  • " 2 !face ." QUIT  " 0 !face
  315.        ." leaves the stack untouched." cr scr
  316.     ."  • Tabs are now converted to spaces before" scr
  317.     ."    interpreting, so they no longer cause errors."
  318.     .arrows ;
  319.  
  320. : P13  cls scr
  321.     ." Notes:" cr scr
  322.     ."  • A DA version is now included. Version 1.6.3" scr
  323.     ."    includes all of the new features except for" scr
  324.     ."    Apple Events support." cr scr
  325.     ."  • " 2 !face ." Grow  " 0 !face
  326.        ." has been removed from the application." scr
  327.     ."    Allocated memory is 32K for both application" scr
  328.     ."    and DA." cr scr
  329.     ."  • Choosing “Save” from the menu confirms your" scr
  330.     ."    choice before overwriting the dictionary." cr scr
  331.     ."                                ( continued ... )"
  332.     .arrows ;
  333.  
  334. : P14  cls scr
  335.     ." Notes, continued ..." cr scr
  336.     ."  • 68040's instruction cache must be disabled" scr
  337.     ."    to correctly compile code." cr scr
  338.     ."  • The floating point interpreter will attempt" scr
  339.     ."    to convert any undefined token to a number." scr
  340.     ."    If the token begins with a number, it will" scr
  341.     ."    be converted causing unexpected results." cr scr
  342.     ."  • Numerous code tightening and speed up" scr
  343.     ."    enhancements have been made."
  344.     .arrows ;
  345.  
  346. : P15  cls scr
  347.     ." Packing list for Pocket Forth, release 6.3:" scr scr
  348.     ."  • The application, Pocket Forth version 0.6.3" scr
  349.     ."  • The desk accessory, PocketDA version 1.6.3" cr scr
  350.     ."  Text files:" scr
  351.     ."  • The Manual parts 1 and 2" scr
  352.     ."  • The Glossary of Pocket Forth words" scr
  353.     ."  • Source code with assembly instructions" scr
  354.     ."     and an assembly script for Frontier." scr
  355.     ."  • Source and Manual Addendum for the DA." cr scr scr
  356.     ."                                ( continued ... )"
  357.     .arrows ;
  358.  
  359. : P16  cls scr
  360.     ."  • Example folder:           (Packing list cont.)" cr scr
  361.     ."                                   create this application" bcr
  362.     ."      Reader" scr
  363.     ."                                   the guts of a text editor" bcr
  364.     ."      TextEdit" scr
  365.     ."                                   the Sieve of Erastothanes" bcr
  366.     ."      Sieve" scr
  367.     ."                                   demonstrate them" bcr
  368.     ."      Window&Menu" scr
  369.     ."                                   read and write ASCII data files" bcr
  370.     ."      DataFiles" scr
  371.     ."                                   floating point trig. functions" bcr
  372.     ."      SANETrig" scr
  373.     ."                                   16/32 bit math functions" bcr
  374.     ."      IntegerTrig" scr
  375.     ."                                   QuickDraw routines with demo" bcr
  376.     ."      Graphics" scr
  377.     ."                                   an RPN scientific calculator" bcr
  378.     ."      Calculator" cr scr scr
  379.     ."                                ( continued ... )"
  380.     .arrows ;
  381.  
  382. : P17  cls scr
  383.     ."  • Extension folder:          (Packing list cont.)" cr scr
  384.     ."                                    Make Pocket Forth mostly" bcr
  385.     ."      Starting folder" scr
  386.     ."                                    compatable with "
  387.                                           4 !face  ." Starting" bcr
  388.     nfont 2 !face ."     ATTENTION" 0 !face sfont scr
  389.     ."                                    " 4 !face  ." Forth"
  390.                                           0 !face  ."  by Leo Brodie!" bcr
  391.     nfont 2 !face ."      BEGINNERS!" 0 !face sfont cr scr
  392.     ."                                    A folder with new event" bcr
  393.     ."      Apple Events" scr
  394.     ."                                    definitions and interface files" scr
  395.     ."                                    for Frontier and HyperCard." cr scr
  396.     ."                                    A library of utility routines." bcr
  397.     ."      Misc" cr scr
  398.     ."                                    The Forth Vendors Group" bcr
  399.     ."      fvgFloatingPoint" scr
  400.     ."                                    floating point standard."
  401.     128 94 161 127 irect !rect  ( set icon rect )
  402.     128 irect .icon  ( draw the icon )
  403.     .arrows ;
  404.  
  405. : P18  cls scr
  406.     ."     If you find a bug, need help, or want to talk" scr
  407.     ."    about this, write. I'd like to hear from you and" scr
  408.     ."    I'll attempt to answer your mail." cr scr
  409.     ."    Do not send any money, Pocket Forth is free!" cr scr
  410.     ."    Contact me at any of the following addresses:" scr
  411.     ."      CompuServe     [70566,1474]" scr
  412.     ."      AOL                   cheilman" scr
  413.     ."      Email                “heilman@pc.maricopa.edu”" scr
  414.     ."      U.S. Mail           PO box 8345" scr
  415.     ."                               Phoenix AZ 85066-8345"
  416.     .aarrow ;
  417.  
  418. \ page list
  419. variable PWHICH  0 pwhich !  ( page-1 to be drawn )
  420. 17 constant PNO  ( number of pages-1 )
  421. create PLIST  ( ordered list of routines or "pages" )
  422.     ' p1 ,  ' p2 ,  ' p3 ,  ' p4 ,
  423.     ' p5 ,  ' p6 ,  ' p7 ,  ' p8 ,
  424.     ' p9 ,  ' p10 , ' p11 ,  ' p12 ,
  425.     ' p13 ,  ' p14 ,  ' p15 ,  ' p16 ,
  426.     ' p17 ,  ' p18 ,
  427.  
  428. ( update, menu, button and idle handlers )
  429. : DOUP  pwhich @ 2* plist + @ execute ;  ( draw the pwhichth page )
  430. : DON ( n -- ) pwhich ! doup ;  ( go to nth page )
  431. : DOAFT  pwhich @ 1 - 0 max don ;  ( decrement pwhich )
  432. : DOFOR  pwhich @ 1+ pno min don ;  ( increment pwhich )
  433. : DOFIRST  0 don ;  ( go to first page )
  434. : DOLAST  pno don ;  ( go to last page )
  435. : DONEW 4 don ;  \ go to "whats new" page
  436. : DOBUG 10 don ;  \ go to "bug fixes" page
  437. : DONOTE 12 don ;  \ go to "notes" page
  438. : DOPACK 14 don ;   \ go to "packing list" page
  439.  
  440. : STOP  -bird bye ; ( stop animating )
  441.  
  442. \ menu list
  443. create GMENU ' dofirst , ' doaft , ' dofor , ' dolast ,
  444.    ' null ,  ' donew ,  ' dobug ,  ' donote ,  ' dopack ,  ' dolast ,
  445. create FMENU ' stop ,
  446. create MBAR fmenu ,  18 +md @ 2+ @ ,  gmenu ,
  447. 2variable GMENUH  0 0 gmenuh 2!  ( holder for goMenuHandle )
  448. ' beep  18 +md @  ( get pointer to menu list )
  449.         2+ @  ( get pointer to Edit menu from menu list )
  450.         8 + !  ( set paste handler to beep )
  451.  
  452. : +MENU ( -- ) ( Turn the new menu on.)
  453.     0 0 2>r 4 >r ,$ A9BF  ( _GetRMenu )
  454.     2r> 2dup 2>r 0 >r ,$ A935  ( _InsertMenu )
  455.     gmenuh 2!  ,$ A937 ;  ( _DrawMenuBar )
  456.  
  457. : DOBUTT  ( -- ) ( button handler )
  458.     @mouse apoly ?phit IF apoly 2@ 2>r ,$ A8C9 doaft ELSE
  459.       @mouse fpoly ?phit IF fpoly 2@ 2>r ,$ A8C9  dofor 
  460.     THEN  THEN ;
  461.  
  462. \ Idle procedure
  463. variable TLAST  0 tlast !  ( timer )
  464. 10 constant DELAY
  465. : TICKS ( -- n ) 364 0 l@ ;
  466. : ?TIME ( -- flags ) ( true if 1/delay seconds has elapsed )
  467.     ticks tlast @ - abs delay > ;
  468. : DOIDLE  ( do the first page animation )
  469.     pwhich @ 0= IF  ( if its the title page )
  470.       ?time IF ticks tlast !  animate
  471.     THEN  THEN ;
  472.  
  473. \ startup procedure
  474. : START  sfont   \ Set to 12 point Chicago
  475.     2 >r ,$ A889  \ SrcXor _TextMode
  476.     +apoly +fpoly       \    This is stuff that must
  477.     +menu  +bird         \   be set up at runtime,
  478.     128 +icon  129 +icon  \  because it uses handles.
  479.     BEGIN ?terminal drop AGAIN ;  ( event loop )
  480.  
  481. \ This is event handlers and data to set up when this is loaded.
  482. ' doup    14 +md !  \ set update handler
  483. ' dobutt  16 +md !  \ set button handler
  484.   mbar    18 +md !  \ set the menu handlers
  485. ' doidle  20 +md !  \ set idle handler
  486. ' stop    22 +md !  \ set quit handler
  487. ' start   26 +md !  \ set startup handler
  488. ' null   136 +md !  \ disable Apple Events
  489. 450 250   8 +md 2!  \ set window size
  490.  
  491. save  bye
  492.